COMMENT ⊗   VALID 00008 PAGES VERSION 17-1(0)
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	HISTORY
 00003 00003	Array Stuff 
 00010 00004	  bexit & stkuwd  
 00018 00005	 array info & the like 
 00022 00006	 the procedure item routines
 00026 00007	
 00032 00008	
 00034 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000000  ⊗;


COMMENT ⊗
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 **** **** VERSION 17-1(0)
VERSION 16(4) 7-24-73 BY RHT BUG #NG# SIMPLE PROC GO TO NS PROC SHOULD SORT OF WORK
VERSION 16(3) 7-24-73 BY RHT BUG #NF# -- FOUND TBITS USE LURKING IN STKUWD
VERSION 16(2) 7-14-73 BY RHT ADD APPLY$
VERSION 16(1) 7-13-73 BY RHT MAKE APPLY RETURN A VALUE LIKE IT IS SUPPOSED TO

⊗;
COMMENT ⊗Array Stuff ⊗

;ARYDIR, ARRPDL, AND FRIENDS ARE NO MORE

DSCR LRCOP, ARCOP
⊗

COMPIL(ARY,<LRCOP,ARCOP,LRMAK,ARMAK,ARYEL,BEXIT,STKUWD
ENTINT <ARRINFO,ARRBLT,ARRTRAN>>
  ,<SAVE,RESTR,CORGET,CORREL,X11,X22,X33,X44,GOGTAB,ARRRCL,RECQQ,LEAP,ALLFOR>
  ,<ARRAY ALLOCATION ROUTINES>)

HERE(LRCOP)
HERE(ARCOP)
;;#HO# 6-7-72 DCS ALLOW BOTH ADDRS TO BE RETURNED
	PUSH	P,B
	PUSH	P,C		;SOME WORK SPACE.
	PUSH	P,-3(P)		;ARRAY TO BE COPIED
	PUSHJ	P,..ARCOP	;COPY IT
	POP	P,C
	POP	P,B
	SUB	P,X22
	JRST	@2(P)		;DONE

↑↑..ARCOP:
;;#HO#
	HRRZ	A,-1(P)		;THE ARRAY TO BE COPIED.
	SKIPGE	-2(A)
	SUBI	A,1		;FOR STRING ARRAYS.
	HLRE	B,-1(A)		;NUMBER OF DIMENSIONS.
	MOVMS	B		;ABSOLUTE VALUE.
	IMUL	B,[-3]
	ADDI	A,-2(B)		;A NOW POINTS TO "CORGET" GUY.
	MOVN	C,-1(A)		;SIZE
	SUBI	C,3		;TO ACCOUNT FOR BOOKEEPING.
	PUSHJ	P,CORGET
	ERR	<NO ROOM FOR ARRAY>
	PUSH	P,B
	HRLI	B,(A)		;MAKE UP A BLT WORD.
	ADDI	C,(B)
	BLT	B,-1(C)		;COPY THE WHOLE ARRAY.
	POP	P,B		;BECAUSE BLT DESTROYS ITS.
	HRRZS	A		;SINCE THE ADDI ABOVE LEFT STUFF IN LEFT HALF.
	MOVNS	A
	ADDI	A,(B)		;A HAS NEW-OLD DIFFERENCE.
	ADDM	A,(B)		;THESE HAVE TO BE RELOCATED.
	ADD	A,-1(P)		;NEW ARRAY DESCRIPTOR.
	HRRM	A,-2(B)		;FOR STRING GARBAGE COLLECTOR.
	MOVE	C,-1(P)		;ARRAY THAT WAS COPIED.
	SKIPGE	-2(C)		;WAS IT A STRING ARRAY?
	SOS	-2(B)		;BACK IT UP ONCE.
	SUB	P,X22
	JRST	@2(P)		;ALL DONE.

DSCR LRMAK
⊗
HERE(LRMAK)
DSCR ARMAK
⊗

HERE (ARMAK)
BEGIN	ARMAK
	PUSHJ	P,SAVE
	HRRZ	A,-1(P)		;#DIMENSIONS
	MOVEI	B,-2(P)		;→BOUNDS(n)
	MOVEI	C,1

MAKLUP:	SOJL	A,SIZDUN	;DONE GETTING TOTAL SIZE
	MOVE	D,(B)		;UPPER BOUND
	ADDI	D,1		;PLUS ONE.
	SUB	D,-1(B)		;  -LOWER BOUND IS TOTAL SIZE
	SKIPG	D		;MUST BE POSITIVE
	 ERR	 <LOWER BOUND ≥ UPPER BOUND>
	IMUL	C,D		;COLLECT SIZE
	SUBI	B,2		;LOOK AT NEXT
	JRST	MAKLUP

SIZDUN:	; MOVEI C,SIZE DESIRED -- ALREADY THERE
	SKIPGE	-1(P)		;IF #DIMS POSITIVE, THEN NOT STRING ARRAY
	LSH	C,1		;MULTIPLY BY TWO FOR STRINGS.
	PUSH	P,C		;SAVE SIZE OF ARRAY ITSELF
	HRRZ	A,-2(P)		;#DIMENSIONS AGAIN
	IMULI	A,3		;SIZE OF ARRAY DESCRIPTOR TABLE
	ADDI	C,2(A)		;ADD TO SIZE OF AREA NEEDED
AGIN:	PUSH	P,C		;SAVE IT
	PUSHJ	P,CORGET		;ARRAY
	 ERR	 <NO ROOM FOR ARRAY>

GOTARR:	POP	P,C		;TOTAL SIZE AGAIN
	MOVE	D,B		;SAVE ADDRESS
	HRRZ	TEMP,B
	ADD	TEMP,C
	POP	P,C		;ARRAY SIZE
	PUSH	P,B		;SAVE →ARRAY BLOCK
	SETZM	(B)
	HRLS	B
	ADDI	B,1
	BLT	B,-1(TEMP)	;CLEAR ARRAY
	HRRZI	B,(D)		;GET ADDRESS BACK
	HRRZ	TEMP,-2(P)	;#DIMENSIONS AGAIN
	SKIPGE	-2(P)		;STRING ARRAY?
	 MOVNS	TEMP		; YES
	HRL	C,TEMP		;#DIMS, TOTAL SIZE (#DIMS NEG IF STRING)
	PUSH	P,C		;SAVE INFORMATION WORD


COMMENT ⊗
LET D→NEXT WORD INTO TABLE,  A=COUNT OF DIMENSIONS LEFT,
    C=ACCUMULATING TOTAL SIZES (AGAIN)
    B→CURRENT DESCRIPTIONS (IN STACK),  TEMP USED FOR MOVING THINGS
⊗

	ADDI	B,1		;LEAVE ROOM FOR ADDRESS WORD
	HRRZ	A,-3(P)		;#DIMS
	MOVE	LPSA,A		;PREPARE FOR SUBRT RETURN
	LSH	LPSA,1
	ADDI	LPSA,2
	HRLS	LPSA
	MOVEI	D,-4(P)		;→INFO
	;MOVE	D,[FIRST WORD]	;ALREADY THERE
	MOVEI	C,1		;MULTIPLY FACTOR
	MOVEI	X,0		;ACCUMULATE TOTAL DISPLACEMENT

STOLUP:	SOJL	A,STODUN
	MOVEW	(<1(B)>,<(D)>) ;UPPER BOUND
	ADDI	TEMP,1
	SUB	TEMP,-1(D)		;TOTAL SIZE
	MOVEM	C,2(B)		;AND MULTIPLY FACTOR
	IMUL	C,TEMP		;TEMP HAS SIZE THIS DIMENSION
	MOVEW	(<(B)>,<-1(D)>)	;STORE LOWER BOUND
	IMUL	TEMP,2(B)	;COLLECT TOTAL DISPLACEMENT
	ADD	X,TEMP		;IN X
	ADDI	B,3
	SUBI	D,2
	JRST	STOLUP		;UPDATE POINTERS AND LOOP


STODUN:	POP	P,(B)		;INFO WORD
	ADDI	B,1		;WILL POINT AT FIRST DATA WORD
	POP	P,TEMP	;→BLOCK HEAD
	HRRZM	B,-2(TEMP)	;STORE WHERE STRNGC CAN FIND IT
	SKIPGE	-1(B)		;IS IT A STRING ARRAY?
	HRROI	B,1(B)		;YES, POINT AT 2D WORD OF FIRST ELEMENT
	MOVEM	B,RACS+1(USER)	;RESULT
	JUMPGE	B,NSTG		;STRING ARRAY?
	 LSH	 X,1		; YES, DOUBLE DISPLACEMENT
NSTG:	SUB	B,X		;ARRAY ADDR - TOTAL DISPLACEMENT
	HLL	B,RACS+1(USER)	;-1 IF STRING, 0 OTHERWISE
	MOVEM	B,(TEMP)	;SAVE IN (0,0,0) WORD
	JRST	RESTR



BEND ARMAK


DSCR ARYEL
⊗

HERE(ARYEL)
BEGIN ARYEL
	HRRZ	B,-1(P)
	POP	P,-1(P)		;PUT POPJ ADDRESS BACK FOR CORREL.
	SKIPGE	-2(B)
	SUBI	B,1		;COMPUTE THE HEADER ADDRESS.
	HLRE	A,-1(B)
	MOVMS	A
	IMUL	A,[-3]
	ADDI	B,-2(A)
	HRRZS	B
	JRST	CORREL		;RELEASE IT.

BEND
COMMENT	⊗  bexit & stkuwd  ⊗
DSCR BEXIT
PARM -- XWD #LEVELS-1,LVI ADDRESS IN LPSA
DES -- RELEASES STROAGE FOR BLOCKS -- REPLACES THE OLD ARRREL
SID -- MANGLES ALL REGISTERS
⊗

HERE(BEXIT)
BEGIN BEXIT
BKCNT←5
BKPTR←6
TPTR←7
EN←10	;ALSO USED BY STKUWD
PDA←11	;THIS IS USED BY STKUWD, BUT SOME OF THE LVIDAC ROUTINES MUST SAVE IT
	;SINCE THEY ARE SOMETIMES USED BY STKUWD -- THIS IS CHEAPEST WAY

	PUSH	P,A			;SAVE A
	HLRE	BKCNT,LPSA		;SAVE COUNT
	HRRZ	BKPTR,LPSA		;POINT
	MOVE	TPTR,[POINT 4,EN,3]	;BYTE PTR FOR TYPE
NXTEN:	MOVE	EN,(BKPTR)		;PICK ONE UP
	LDB	A,TPTR			;PICK UP TYPE
	PUSHJ	P,@[ ↑↑LVIDAC:	DRYROT
				RARY	;1
				RARY	;2
				SLFRE	;3 -- SET OR LIST
				LAFRE	;LEAP ARRAY OF SETS OR LISTS
	
				FEVAR	;5 FOR EACH CONTROL VARIABLE
				KLIST	;6  
				CTEXTT	;7 CONTEXT
				CLNUP	;10
				DRYROT	;11
				DRYROT	;12
				DRYROT	;13
				DRYROT	;14
				DRYROT	;15
				DRYROT	;16
				BKE	;17 END OF BLOCK AREA
				](A)
	AOJA	BKPTR,NXTEN	;GET NEXT

DRYROT: ERR <DRYROT AT BEXIT>
	POPJ	P,
RARY:	SKIPN   C,@EN
	POPJ	P,
	EXCH	C,(P)		;CLEVER WAY TO FIX THE STACK FOR CALL TO
				;ARYEL
	PUSH	P,C
	SETZM	@EN		;SAY IT IS GONE
	JRST	ARYEL		;MAKE IT THE TRUTH
SLFRE:	SKIPN	A,@EN		;
	POPJ	P,
	SETZM	@EN		;ZERO OUT THE DESCRIPTOR
	PUSH	P,5		;SAVE IT
	PUSH	P,6
	MOVEI	5,0		;FOR RECLAIMER
	PUSHJ	P,RECQQ		;SINCE SET
	POP	P,6
	POP	P,5
	POPJ	P,
CTEXTT: SKIPN	A,@EN		;CONTEXT EMPTY?
	POPJ	P,		;YES
	PUSH	P,EN		;CONTEXT ADDRESS
	PUSHJ	P,ALLFOR	;FORGET EVERYTHING
	POPJ	P,

LAFRE:	SKIPN	A,@EN		;ARRAY PTR
	POPJ	P,		;NOBODY HOME
	PUSH	P,A
	SETZM	@EN
	PUSHJ	P,ARRRCL	;JRL'S MAGICAL SET ARRAY ZAPPER
	EXCH	A,(P)		;CLEVER TRICK AGAIN
	PUSH	P,A		;
	JRST	ARYEL		;GIVE UP THE SPACE
BKE:	SOJGE	BKCNT,GETNXT	;DO WE NEED TO DO MORE?
	MOVE	A,-1(P)
	SUB	P,[XWD 3,3]	;
	JRST	@1(P)		;NO
GETNXT:	MOVEI	BKPTR,@EN	;GET LINK
	SOJGE	BKPTR,CPOPJ	;WILL COMPENSATE FOR AOS
	ERR 	<DRYROT AT BEXIT -- WENT TOO FAR>
FEVAR:	SKIPN	A,@EN
CPOPJ:	POPJ	P,
	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
; NOW CALL LEAP TO RELEASE FOREACH
	MOVEI	5,47		;CHANGED (11-30-72) TO REFLECT NEW INDICES
	PUSHJ	P,LEAP
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,
KLIST:	SKIPN	A,@EN
	POPJ	P,
	ERR	<UNTERMINATED PROCESS DEPENDS ON A BLOCK BEING EXITED 
MAY CONTINUE >,1
	POPJ	P,


CLNUP:	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
	PUSHJ	P,(EN)		;CALL THE PROUCEDURE
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,

BEND BEXIT

HERE (STKUWD)
BEGIN	STKUWD
DSCR STKUWD
DES THIS PROCEDURE UNWINDS THE STACK TO ESTABLISH A CORRECT DISPLAY AND
	LEXIC LEVEL.
PAR LPSA=XWD CORRECT LL,CORRECT DL
SID MANGLES YOUR ACS (EXCEPT F, P, SP -- WHICH ARE PROPERLY FIXED UP)
⊗

CDLSAV←5
LLFGR←6
SIN←7
EN←10
PDA←11

	MOVE	USER,GOGTAB		
	POP	P,STKURT(USER)		;REMEMBER RETURN ADDRESS
	HRRZM	LPSA,CDLSAV		;
	HLROM	LPSA,LLFGR		;SET UP PARAMETERS FOR USE 
PLOOP:	HLRZ	PDA,1(RF)		;PICK UP PROC DESC ADDRESS
;;#LP# (25 FEB 73)1 OF 1 -- RHT -- MUST CHECK FOR GO TO OUT OF PROCESS
	CAIN	PDA,0			;IS THIS THE BITTER END
	ERR	<GO TO OUT OF A PROCESS WILL NOT WORK> ;YES
;;#LP#
;;#NG# -- RHT ALWAYS ADJUST STACKS BEFORE DO LVI NOW!
	MOVE	SP,2(RF)		;OLD OLD SP
	HLLZ	A,PD.DSW(PDA)		;EXTRA SS DISPL NEED
	HLR	A,A			;BOTH SIDES
	ADD	SP,A			;
	HRRZ	A,PD.DSW(PDA)		;ARITH STK DISPL
	ADDI	A,(RF)			;+RF
	HRRZ	B,P			;WHERE WE ARE NOW
	SUB	B,A			;HOW FAR BACK TO GO
	HRL	B,B			;BOTH SIDES
	SUB	P,B			;TRIMMED BACK
;;#NG# 
	CAMN	PDA,CDLSAV		;IS THIS THE PARENT ???
	HRRZS	LLFGR			;USE THIS AS A FLAG
	HRRZ	SIN,PD.LLW(PDA)		;POINTER AT LVI INFO
NXTEN:	SKIPN	EN,(SIN)		;A ZERO SAYS
	JRST	EOPD			;WE ARE AT END OF LOC VAR INF
TPGET:	LDB	A,[POINT 4,EN,3]	;TYPE FIELD
	CAIN	A,17			;IGNORE END OOF BK ENTRIES
	AOJA	SIN,NXTEN
	JUMPL	LLFGR,DOIT		;IF NOT AT RIGHT DL, ZAP EM ALL
	LDB	B,[POINT =9,EN,=12]	;LL FIELD
	CAMG	B,LLFGR			;IF LEX LEV IS LOW ENOUGH
	AOJA	SIN,NXTEN		;LET HIM LIVE -- VERY INEFFICIENT CODE
DOIT:	PUSHJ	P,@LVIDAC(A)		;CALL APPROPRIATE ROUTINE
	AOJA	SIN,NXTEN
EOPD:	JUMPL	LLFGR,EOPD.1		;RETURN TEST
	MOVE 	USER,GOGTAB		;
	JRST	@STKURT(USER)
EOPD.1:	HRRZ	SIN,PD.DLW(PDA)		;NOW HAVE TO CLEAR OUT SET FORMALS
	HRRZ	B,PD.NPW(PDA)		;#ARITH +1
	MOVE	C,RF			;F REG
	SUBI	C,1(B)			;C← →→ 1 BEFORE 1'ST ARITH PARM
PARLP:	SOJLE	B,ADJSKS		;COUNT DOWN # ARGS
	AOS	C			;POINT AT NEXT
	MOVE	B,(SIN)			;TYPE CODE
;;#NF# RHT 24 JULY 73 THIS PIECE OF CODE WAS STILL USING TBITS
	TLC	B,SETYPE⊗5		;VALUE SET MUST BE RELEASED
	TLNN	B,REFB!ITEMB!PROCB	;THESE ARE NOT RELEASED
	TLNE	B,MSK6BT		;CHECK THE SET CODE
;;#NF#
	AOJA	SIN,PARLP		;IF NOT VALUE SET, NO PROBLEMS
	MOVEI	EN,(C)			;EN←← PTR TO SET
;; BY JRL 8-31- 72 FOLLOWING INSTRUCTION WAS PUSHJ P,@LVIDAC+4
	PUSHJ	P,@LVIDAC+3		;CALL SET RELEASER
	AOJA	SIN,PARLP		;GO ON TO NEXT
ADJSKS:	HRRZ	RF,(RF)			;BACK A DYNAMIC LINK
;;#NG# -- USED TO ADJUST STACKS HERE
	JRST	PLOOP			;

BEND STKUWD

COMMENT ⊗ array info & the like ⊗

DSCR INTEGER←ARRINFO(ARRAY,CODE);
CAL SAIL
⊗

HERE (ARRINFO)
BEGIN ARRINFO
	MOVE	A,-2(P)	;ARRAY ADDRESS
	SKIPGE	-2(A)	;STRING ARRAY?
	 SUBI	 A,1		; YES, BACK UP FOR IT
	SKIPGE	TEMP,-1(P)	;CONTROL PARAMETER
	 JRST	 [HLRE A,-1(A) ;WANTS NUMBER OF DIMENSIONS
		   JRST RSINFO]
	JUMPE	TEMP,[HRRZ A,-1(A) ;WANTS TOTAL SIZE
			JRST RSINFO]
; WANTS A BOUND
	ROT	TEMP,-1		;SAVE LOW ORDER BIT AS SIGN
	MOVNI	LPSA,3		;GET DISPLACEMENT INTO ARRAY TABLE
	IMULI	LPSA,(TEMP)
	SKIPGE	TEMP		;WANT UPPER OR LOWER BOUND
	SUBI	LPSA,4
	HRLI	A,LPSA
	MOVE	A,@A		;GET THE REQD BOUND
RSINFO:	
	SUB	P,X33
	JRST	@3(P)
BEND ARRINFO

DSCR ARRBLT(@DEST,@SOURCE,LENGTH);
CAL SAIL
⊗

HERE (ARRBLT) 
BEGIN ARRBLT
	HRRZ	TEMP,-3(P)
	HRL	TEMP,-2(P)
	SOS	LPSA,-1(P)
	ADDI	LPSA,(TEMP)
	BLT	TEMP,(LPSA)
	SUB	P,X44
	JRST	@4(P)
BEND  ARRBLT

DSCR ARRTRAN(DEST ARRAY,SOURCE ARRAY);
CAL SAIL
⊗

HERE (ARRTRAN)
BEGIN ARRTRAN
	HRRZ	TEMP,-2(P)		;DEST ARRAY ADDR
	HRRZ	LPSA,-1(P)		;SOURCE ARRAY ADDR
	SKIPL	-2(TEMP)		;STRING ARRAY?
	 JRST	 NSTR			; NO
	SUBI	TEMP,1
	SUBI	LPSA,1

NSTR:	HRL	TEMP,LPSA		;BLT WORD
	HRRZ	LPSA,-1(LPSA)		;SOURCE SIZE
	HRRZ	USER,-1(TEMP)
	CAMLE	LPSA,USER
	 HRRZ	 LPSA,USER
	ADDI	LPSA,-1(TEMP)		;TERMINATION WORD
	BLT	TEMP,(LPSA)
	SUB	P,X33
	JRST	@3(P)
BEND ARRTRAN

ENDCOM(ARY)

IFE ALWAYS, <
COMPIL(DM1,<RECQQ,ARRRCL,LEAP>,,<DUMMY LEAP BEXIT TARGETS>)
↑↑RECQQ:
↑↑ARRRCL:
↑↑LEAP: 
	ERR <DRYROT-LIBRARY>
ENDCOM(DM1)
COMPIL(DM2,<SPRPDA,RESUME,TERMIN,SPROUT,DADDY,CURSCB>,,<DUMMY PROCESS VARIABLES>)
↑↑SPRPDA:
↑↑RESUME:
↑↑TERMIN:
↑↑SPROUT:
↑↑DADDY:
↑↑CURSCB:
	ERR <DRYROT-LIBRARY>
ENDCOM(DM2)
COMPIL(DM3,<ALLFOR>,,<DUMMY BACKTRACKING BEXIT TARGET>)
↑↑ALLFOR:
	ERR <DRYROT-LIBRARY>
ENDCOM(DM3)

COMPIL(DM4,<APPL$Y>,,<DUMMY APPLY PD ENTRY>)
↑↑APPL$Y: 
	.+1
	ERR <DRYROT-LIBRARY>
ENDCOM(DM4)
>;IFE ALWAYS


COMMENT ⊗ the procedure item routines
⊗

COMPIL(PIT,<PITCOP,PITBND,APPLY,PITDTM>,<GINFTB,INFTB,DATM,GDATM,GOGTAB,RECQQ>
	,<PROCEDURE ITEM ROUTINES>,<APPL$Y>)

COMMENT ⊗ APPLY$ IS NOT MADE AN ENTRY.  HOWEVER IT IS INTERNALED.  THUS
PIT WILL NOT BE LOADED SIMPLY BECAUSE OF THE EXTERNAL REQUEST IN SAIPRC
FOR APPLY$ ⊗

BEGIN PITS
FLAG←0;
PDA ← 4
NPW ← 5
FPTR←6
FRM←7
APTR←10

GLOB <
GBRK←←6000 
>;GLOB

DSCR PITBND,PITCOP
CAL
	PUSH P,DITM
	PUSH P,XXX
	PUSHJ P,PITBND	<OR PITCOP>

PARM DITM IS ITEM TO BE MADE INTO PROCEDURE ITEM
	FOR PITBND, XXX IS PDA OF PROC TO BE BOUND
	FOR PITCOP, XXX IS PROCEDURE ITEM NUMBER
DES PUTS INTO DITM'S DATUM: XWD STATIC LINK,PDA &SETS DITM'S TYPE TO PITTYP
SID MANGLE TEMP,LPSA,USER,B,C
⊗



HERE (PITBND)
	HRRZ	LPSA,-1(P)		;PICK UP PDA
	HRRZ	TEMP,PD.PPD(LPSA)	;PARENT'S PDA
;;#LM# ↓ WAS A SKIPE
	SKIPN	PD.PPD(TEMP)		;IF DADDY IS THE GLOBAL MAN (IE
	JRST	PUTDTM			;THE OUTER BLOCK -- INDICATED BY HIS
					;HAVING NO FATHER -- THEN DONT LOOK FOR
					;A STATIC LINK -- YOU WILL USE 0

	SKIPA	USER,RF			;
CTXTLP:	HRRZ	USER,(USER)		;GO UP A LINK
	HLRZ	B,1(USER)		;PDA AT THIS LEVEL.  NOTE WE
	CAME	TEMP,B			;FIRST LOOK AT THIS GUY
	JRST	CTXTLP			;NOT THE ONE
	HRL	LPSA,USER		;NOW LPSA IS SL,,PDA
	JRST	PUTDTM			;GO PUT IN THE DATUM

HERE(PITCOP)
	MOVE	C,-1(P)			;PICK UP ITEM NO INTO B
	PUSHJ	P,PITDGT		;GET DATUM
PUTDTM:	MOVE 	C,-2(P)			;TARGET
	MOVEI	TEMP,PITTYP		;SPECIAL CODE
GLOB <
	CAIL 	C,GBRK			;IS IT GLOBAL???
	JRST	[
		TERPRI	<DON'T BIND PROCEDURES TO GLOBAL ITEMS>
		CAI	C,
		ERR	<ITEM NUMBER>,6
		]
	>;GLOB

	MOVE	USER,GOGTAB
	DPB	TEMP,INFOTAB(USER)	;PUT IN NEW DATUM TYPE
	MOVEM	LPSA,@DATAB(USER)	;SET DATUM
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN

PITDGT:					;PROCEDURE TO GET PIT DATUM
	MOVE	LPSA,GOGTAB
GLOB <
	CAIL	C,GBRK			;
	MOVE	LPSA,GLUSER
>;GLOB
	LDB	B,INFOTAB(LPSA)
	CAIE	B,PITTYP		;IS IT A PROCEDURE ITEM???
	JRST	[ CAI C,
		ERR <NOT A PROCEDURE ITEM >,6]
GLOB <
	CAIL	C,GBRK
	ERR	<DRYROT AT PITDGT>
>;GLOB
	MOVE	LPSA,@DATAB(LPSA)	;FETCH DATUM
	POPJ	P,

DSCR PITDTM
CAL 	PUSH	P,PIT NO
	PUSHJ	P,PITDTM
DES	SETS THE TOP OT THE STACK TO THE DATUM OF THE PROCEDURE ITEM
⊗

HERE(PITDTM)
	MOVE	C,-1(P)			;PICK UP ITEM NO
	PUSHJ	P,PITDGT		;GET ITS DATUM
	MOVEM	LPSA,-1(P)		;SET IT DOWN INTO THE STACK
	POPJ	P,

DSCR APPLY
CAL 
	PUSH	P,[xwd context,pda]
	PUSH	P,ARGLIS
	PUSHJ	P,APPLY
DES  
	APPLY is the interpretive caller. Essentially, it uses the items
in ARGLIS to build a procedure call on the procedure named by the pda.
If context=0, then the procedure is just called in the normal manner. 
If context is not zero, then APPLY will build a MSCP, using this value
as the static link, and will jrst to the instruction after the mscp.

⊗

HERE(APPL$Y)
	APPLY	;A FAKED UP PD SO CAN SPROUT APPLY
		;NOTE HERE THAT FOR UP WILL HAVE TO GO THROUGH 1 MORE 
		;LEVEL OF INDIRECTION

HERE(APPLY)
	MOVE	PDA,-2(P)
	MOVE	NPW,PD.NPW(PDA)		;THE STACK DISPLACEMENTS
	HRRZ	FPTR,PD.DLW(PDA)	;POINT AT FORMALS
NOGLOB <
	MOVE	USER,GOGTAB		;
>;NOGLOB
	SKIPN	APTR,-1(P)		;ARG LIST
	JUMPN	FPTR,NEACTS		;NULL ACTS,NON NULL FRMS
NXTP:	SOJLE	NPW,ARGSON		;HAD ENOUGH?
	HLRZ	FRM,(FPTR)		;NEXT FORMAL TYPE
	HRRZ	APTR,(APTR)		;LOOK AT NEXT ACTUAL
	JUMPE	APTR,NEACTS		;DONT HAVE ONE
	HLRZ	C,(APTR)		;THE ITEM
GLOB <
	MOVE	USER,GOGTAB		;
	CAIL	C,GBRK			;GLOBAL ??
	MOVE	USER,GLUSER		;
>;NOGLOB
	LDB	A,INFOTAB(USER)		;GET TYPE
	CAIE	A,RFITYP		;REF ITEM?
	JRST	[ PRINT <APPLY -- NON REFERENCE ITEM USED IN ACT PARAM LIST>
		JRST	BARG1
		]
	MOVE	A,@DATAB(USER)		;GET THE DATUM
	TRNE	FRM,ITEMB		;FORMAL AN ITEM?
	JRST 	FITEM			;YES
	TLNE	A,ITEMB			;ACTUAL AN ITEMVAR TYPE THING?
	JRST	BFACT			;LOSE ON CORRESP
	MOVE	B,A			;CHECK 6 BIT TYPE CORRESP
	TLC	B,(FRM)			;
	TLNE	B,MSK6BT		;TEST 6 BIT MASK
	JRST	BFACT			;MAY LATER CONSIDER COERCING
	TRNE	FRM,REFB		;
	JRST	FRMREF			;FORMAL IS A REF
	TLC	A,STTYPE		;STRING ?
	TLNN	A,MSK6BT		;WELL?
	JRST	STVPSH			;YOU BETCHA
	PUSH	P,@A			;PUSH THE VALUE OF THE ARG
	AOJA	FPTR,NXTP		;GO GET NEXT
STVPSH:	PUSH	SP,-1(A)		;PUSH A STRING
	PUSH	SP,(A)			;
	ADD	NPW,[XWD -2,1]		;FIX FOR THE SOJ AT NXTP
	AOJA	FPTR,NXTP
FRMREF:	MOVEI	A,@A			;THE ADDRESS
	PUSH	P,A			;THE REF
	AOJA	FPTR,NXTP		;NEXT
FITEM:	TLNN	A,ITEMB			;IS ACTUAL AN ITEM TOO
	JRST	BFACT			;YOU LOSE!
	MOVE	B,A			;GET ACTUAL BITS
	TLC	B,(FRM)			;6 BIT TYPES
	TRNN	FRM,MSKUNT		;FORMAL HAS 6 BIT TYPE?
	JRST	OK6BT			;NO
	TLNE	B,MSK6BT		;WIN?
	JRST	BFACT			;NO
OK6BT:	TLNE	B,ARY2B			;THE ARY2 BIT OK?
	JRST	BFACT			;NO
	TLNE	A,BINDB			;BINDING ACTUAL?
	JRST	BNDACT			;YES
	TLNE	A,QUESB			;? ACTUAL?
	JRST	QUEACT			;YES
	TLNN	FRM,REFB		;FORMAL REF?
	JRST	FRMREF			;YES
	PUSH	P,@A			;PUSH THE ITEM
	AOJA	FPTR,NXTP		;FETCH NEXT
BNDACT:	TRNN	FRM,QUESB		;FORMAL BETTER BE ?
	JRST 	BFACT
PSHBRF:	MOVEI	A,@A
	TLO	A,20			;TURN ON INDIR BIT
	PUSH	P,A			; @ REF
	AOJA	FPTR,NXTP		; GO DO NEXT
QUEACT:	TRNN	FRM,QUESB		;BETTER BE ?
	JRST	BFACT
	MOVE	B,@A			;GET  THE VALUE NOW
	CAIN	B,UNBND			;HAVE A BINDING?
	JRST	PSHBRF			;NO
	PUSH	P,B			;YES
	AOJA	FPTR,NXTP		;

BFACT:	PRINT	<BAD CORRESPONDENCE BETWEEN ACTUAL & FORMAL PARAMETER TYPE>
BARG1:	JSP	TAC1,PRTARG		;
	JSP	TAC1,PITERR
	JSP	TAC1,PSPFIX		;FIX P & SP
	JRST	CRET			;EXIT FROM IT ALL

PRTARG:	MOVEI	FLAG,1(FPTR)		;FORMAL POINTER
	SUB	FLAG,PD.DLW(PDA)	;ORIGIN
	HRRZ	FLAG,FLAG		;GET THE RH OF IT
	TERPRI
	PRINT	<ARGUMENT NUMBER >
	DECPNT	FLAG
	TERPRI
	JRST	(TAC1)			;RETURN
PSPFIX:	MOVE	A,PD.NPW(PDA)
	SUB	A,NPW			;
	SUBI	P,(A)			;FIXUP RIGHT
	HRLZ	FLAG,A			;
	ADD	P,FLAG			;FIX LEFT
	MOVS	A,A
	SUBI	SP,(A)			;
	HRLZ	FLAG,A
	ADD	SP,FLAG			;FIX SP
	MOVEI	A,0
	JRST	(TAC1)			;RETURN

NEACTS: TERPRI
	PRINT	<APPLY--NOT ENOUGH ACTUAL PARAMETERS SUPPLIED >
	JRST	BARG1


ARGSON:	TLNN	PDA,-1			;WERE WE GIVEN A CONTEXT
	JRST 	CAL1			;NO
	PUSH	P,[CRET]		;PUSH	RETURN ADDRESS
	PUSH	P,RF
	HRRZ	A,PD.PPD(PDA)		;PARENTS PDA
	MOVS	B,PDA			;PDA,,STATIC LINK
	HLRZ	FRM,1(B)			;PDA OF DADDY???
	CAME	FRM,A			;????
	JRST	[
		PRINT	<CONTEXT WRONG OR CLOBBERED IN INTERP CALL>
		JSP	TAC1,PITERR
		JSP	PSPFIX
		JRST	CRET
		]
	PUSH	P,B			;STATIC LINK
	PUSH	P,SP			;
	HLRZ	A,PD.PPD(PDA)		;WORD AFTER MKSEMT
	JRST	(A)			;GO THERE
CAL1:	HRRZ	A,PD.(PDA)		;ENTRY ADDRESS
	PUSHJ	P,(A)			;CALL IT
CRET:	MOVE	PDA,-2(P)		;HERE ON RETURN
	MOVE	FRM,PD.PDB(PDA)		;PROC type
	TLC	FRM,STTYPE		;SIMPLE STRING?
	TLNN	FRM,MSK6BT!ITEMB	;WELL?
	SUB	SP,[XWD 2,2]		;POP	SP STACK
	SKIPGE	B,-1(P)			;GET THE LIST 
	PUSHJ	P,RECBQQ		;ARGL WAS TEMP, RELEASE IT
	SUB	P,[XWD 3,3]
	JRST	@3(P)			;RETURN


PITERR:	TERPRI 
	PRINT <PROCEDURE IS >
	TERPRI
	PUSHJ	P,PRPID
	ERR	<IF YOU CONTINUE, THE PROCEDURE WILL NOT BE CALLED >,1
	JRST	(TAC1)

PRPID:	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	HRRZ	B,PD.ID1(PDA)
	MOVE	A,PD.ID2(PDA)
	SOJL	B,.+4
	ILDB	C,A
	TTCALL	1,C
	JRST	.-3
	POP	P,C
	POP	P,B
	POP	P,A
	POPJ	P,

RECBQQ:	EXCH 	A,B
	PUSHJ	P,RECQQ
	MOVE	A,B
	POPJ	P,

BEND PITS
ENDCOM(PIT)
BEND GOGOL
INTERNAL ..PAT.
..PAT.:
PATCH:	BLOCK	50